Celestin Apprentice 7/Apprentice-Release7.iso/Source Code/Pascal/Applications/NIH Image 1.62b11/Macros/Stacks

Text File | 1997-04-11 | 13KB | 638 lines

{This file contains macros that work with stacks.}

procedure CheckForStack;
begin
  if nPics=0 then begin
    PutMessage('This macro requires a stack.');
    exit;
  end;
  if nSlices=0 then begin
    PutMessage('This window is not a stack.');
    exit
  end;
end;


macro 'Add Slice [A]';    begin CheckForStack; AddSlice end;
macro 'Delete Slice [D]'; begin CheckForStack; DeleteSlice end;
macro 'First Slice [F]';  begin CheckForStack; SelectSlice(1) end;
macro 'Last Slice [L]';   begin CheckForStack; SelectSlice(nSlices) end;

macro 'Select Slice… [S]';
var
  n:integer;
begin
 CheckForStack;
 n:=GetNumber('Slice Number:',trunc(nSlices/2));
 SelectSlice(n)
end;


macro '(-' begin end;

macro 'Smooth';
var
  i:integer;
begin
  CheckForStack;
  for i:= 1 to nSlices do begin
    SelectSlice(i);
    SetOption; Smooth;
  end;
end;


macro 'Sharpen';
var
  i:integer;
begin
  CheckForStack;
  for i:= 1 to nSlices do begin
    SelectSlice(i);
    SetOption; Smooth;
    SetOption; Sharpen;
  end;
end;


macro 'Reduce Noise';
var
  i:integer;
begin
  CheckForStack;
  for i:= 1 to nSlices do begin
    SelectSlice(i);
    ReduceNoise;
  end;
end;


macro 'Apply LUT';
var
  i,stack,slices:integer;
begin
  CheckForStack;
  stack:=PicNumber;
  slices:=nSlices;
  Duplicate('Temp');
  for i:= 1 to slices do begin
    SelectPic(stack);
    SelectSlice(i);
    ApplyLut;
    SelectPic(nPics);
    if i<>slices then PropagateLut;
  end;
  SelectPic(nPics);
  Dispose;
end;


macro 'Fix Colors';
{
Changes 0 to 1 and 255 to 254 in all slices. We want to do this because
pixel values of 0(which always displays as white) and 255(always
displays as black) cause problems when pseudo-coloring images.
}
var
  i:integer;
begin
  CheckForStack;
  for i:= 1 to nSlices do begin
    SelectSlice(i);
    ChangeValues(0,0,1);
    ChangeValues(255,255,254);
  end;
end;

macro 'Subtract Background…';
var
  radius,i:integer;
begin
  CheckForStack;
  radius:=GetNumber('Rolling ball radius (pixels):',50);
  for i:= 1 to nSlices do begin
    SelectSlice(i);
    SubtractBackground('2D Rolling Ball',radius);
  end;
end;


macro '(-' begin end;


procedure CheckForSelection;
var
  x1,y1,x2,y2,LineWidth:integer;
begin
  GetRoi(RoiLeft,RoiTop,RoiWidth,RoiHeight);
  GetLine(x1,y1,x2,y2,LineWidth);
  if (RoiWidth=0) or (x1>=0) then begin
    PutMessage('Please make a rectangular selection.');
    exit;
  end;
end;


procedure CropAndScale(fast:boolean; angle:real);
var
  i,OldStack,NewStack:integer;
  RoiLeft,RoiTop,RoiWidth,RoiHeight:integer;
  N,NewWidth:integer;
  ScaleFactor:real;
  OneToOne:boolean;
begin
  CheckForStack;
  CheckForSelection;
  SaveState;
  OldStack:=PicNumber;
  N:=nSlices;
  ScaleFactor:=GetNumber('Scale factor(0.05..25):',1.0);
  OneToOne:=ScaleFactor=1.0;
  NewWidth:=round(RoiWidth*ScaleFactor);
  if odd(NewWidth) then begin
    NewWidth:=NewWidth-1;
    ScaleFactor:=NewWidth/RoiWidth;
  end;
  SetNewSize(RoiWidth*ScaleFactor,RoiHeight*ScaleFactor);
  MakeNewStack('Stack');
  NewStack:=PicNumber;
  if not OneToOne then begin
    if fast
      then SetScaling('Nearest; Create New Window')
      else SetScaling('Bilinear; Create New Window');
  end;
  SelectPic(OldStack);
  for i:= 1 to N do begin
    SelectSlice(1);
    if OneToOne and (angle=0.0) then Duplicate('Temp')
      else ScaleAndRotate(ScaleFactor,ScaleFactor,angle);
    SelectAll;
    Copy;
    SelectPic(NewStack);
    if i<>1 then AddSlice;
    Paste;
    SelectPic(nPics);
    Dispose; {Temp}
    SelectPic(OldStack);
    DeleteSlice;
  end;
  Dispose; {OldStack}
  RestoreState;
end;

macro 'Crop and Scale-Fast…';   begin CropAndScale(true, 0); end;
macro 'Crop and Scale-Smooth…'; begin CropAndScale(false, 0); end;

procedure Rotate(left:boolean);
var
  i,OldStack,NewStack:integer;
  RoiLeft,RoiTop,RoiWidth,RoiHeight:integer;
  N,NewWidth:integer;
  ScaleFactor,SliceSpacing:real;
  OneToOne:boolean;
begin
  CheckForStack;
  SelectAll;
  GetRoi(RoiLeft,RoiTop,RoiWidth,RoiHeight);
  OldStack:=PicNumber;
  SliceSpacing:=GetSliceSpacing;
  N:=nSlices;
  SetNewSize(RoiHeight,RoiWidth);
  MakeNewStack('Stack');
  if SliceSpacing>0 then SetSliceSpacing(SliceSpacing);
  NewStack:=PicNumber;
  SelectPic(OldStack);
  for i:= 1 to N do begin
    SelectSlice(1);
    if left
      then RotateLeft(true)
      else RotateRight(true);
    SelectAll;
    Copy;
    SelectPic(NewStack);
    if i<>1 then AddSlice;
    Paste;
    ChoosePic(nPics);
    Dispose;
    SelectPic(OldStack);
    DeleteSlice;
  end;
  Dispose;
end;


macro 'Rotate Left';  begin rotate(true) end;
macro 'Rotate Right'; begin rotate(false) end;


macro 'Rotate…';
var
  angle:real;
begin
  angle:=GetNumber('Angle(-180.0°..180.0°):',45.0);
  CropAndScale(false, angle);
end;


macro 'Invert';
var
  i:integer;
begin
  CheckForStack;
  for i:= 1 to nSlices do begin
    SelectSlice(i);
    Invert;
  end;
end;


procedure flip(vertical:boolean);
var
  i:integer;
  SliceSpacing:real;
begin
  CheckForStack;
  for i:= 1 to nSlices do begin
    SelectSlice(i);
    if vertical
      then FlipVertical
      else FlipHorizontal;
  end;
end;

macro 'Flip Vertical';   begin flip(true) end;
macro 'Flip Horizontal'; begin flip(false) end;


macro 'Delete Even Slices';
var
  n:integer;
begin
  CheckForStack;
  SelectSlice(2);
  repeat
    DeleteSlice;
    n:=SliceNumber;
    n:=n+2;
    if n>nSlices then exit;
    SelectSlice(n);
   until false;
end;


macro 'Replicate Slices…';
var
  n,i,RepFactor:integer;
begin
  CheckForStack;
  RepFactor:=GetNumber('Replication factor(2,3,4,5,etc):',2);
  n:=nSlices;
  repeat
    SelectSlice(n);
    SelectAll;
    Copy;
    for i:=2 to RepFactor do begin
      AddSlice;
      Paste;
    end;
    n:=n-1;
   until n=0;
   KillRoi;
end;


macro 'Merge Two Stacks';
{
Combines two stacks(w1xh1xd1 and w2xh2xd2) to create a new
w1+w2 x max(h1,h2) x max(d1,d2) stack. For example, a 256x256x40
and a 256x256x30 stack would be combined into one 512x256x40 stack.
}
var
  i,w1,w2,w3,h1,h2,h3,d1,d2,d3:integer;
begin
  SaveState;
  if nPics<>2 then begin
    PutMessage('This macro operates on exactly two stacks.');
    exit;
  end;
  SelectPic(1);
  GetPicSize(w1,h1);
  d1:=nSlices;
  SelectPic(2);
  GetPicSize(w2,h2);
  d2:=nSlices;
  if d1>=d2
    then d3:=d1
    else d3:=d2;
  if d3=0 then begin
    PutMessage('Both images must be stacks.');
    exit;
  end;
  w3:=w1+w2;
  if h1>=h2
    then h3:=h1
    else h3:=h2;
  SetNewSize(w3,h3);
  MakeNewStack('Merged');
  for i:=1 to d3 do begin
    SelectPic(1);
    SelectSlice(1);
    SelectAll;
    Copy;
    DeleteSlice;
    SelectPic(3);
    MakeRoi(0,0,w1,h1);
    Paste;
    SelectPic(2);
    SelectSlice(1);
    SelectAll;
    Copy;
    DeleteSlice;
    SelectPic(3);
    MakeRoi(w1,0,w2,h2);
    Paste;
    if i<d3 then AddSlice;
  end;
  SelectPic(1);
  Dispose;
  SelectPic(1);
  Dispose;
  RestoreState;
end;


macro 'Average Two Stacks';
{Creates the frame by frame average of two stacks.}
var
  i,w1,w2,w3,h1,h2,h3,d1,d2,d3,avg:integer;
begin
  RequiresVersion(1.53);
  SaveState;
  if nPics<>2 then begin
    PutMessage('This macro operates on exactly two stacks.');
    exit;
  end;
  SelectPic(1);
  KillRoi;
  GetPicSize(w1,h1);
  d1:=nSlices;
  SelectPic(2);
  KillRoi;
  GetPicSize(w2,h2);
  d2:=nSlices;
  if d1>=d2
    then d3:=d1
    else d3:=d2;
  if (w1<>w2) or (h1<>h2) or (d1<>d2) or (d1=0)  then begin
    PutMessage('This macro requires two stacks that are the same size.');
    exit;
  end;
  SetNewSize(w1,h1);
  MakeNewStack('Average');
  avg:=PicNumber;
  for i:=1 to d1 do begin
    SelectPic(1);
    SelectSlice(i);
    SelectPic(2);
    SelectSlice(i);
   ImageMath('Add', 1, 2, 0.5, 0, 'Temp');
    SelectAll;
    Copy;
    dispose;
    SelectPic(avg);
    if i<>1 then AddSlice;
    paste;
   end;
  RestoreState;
end;


macro 'Concatenate Two Stacks';
var
  i,w1,w2,h1,h2,d1,d2:integer;
begin
  RequiresVersion(1.61);
  SaveState;
  if nPics<>2 then
    exit('Exactly two stacks required.');
  SelectPic(1);
  GetPicSize(w1,h1);
  d1:=nSlices;
  SelectPic(2);
  GetPicSize(w2,h2);
  d2:=nSlices;
  if (d1=0) or (d2=0) or (w1<>w2) or (h1<>h2) then
    exit('Two stacks with the same dimensions required.');
        SelectPic(1);
  SelectSlice(d1);
  for i:=1 to d2 do begin
    ChoosePic(2);
    SelectSlice(1);
    SelectAll;
    Copy;
    DeleteSlice;
    ChoosePic(1);
    AddSlice;
    MakeRoi(0,0,w1,h1);
    Paste;
  end;
  SelectPic(2);
  Dispose;
  RestoreState;
end;


macro '(-' begin end;


macro 'Save Slices as files…';
{
This macro saves the slices in a stack as individual TIFF or PICT files using
names of the form needed by Apple's Convert to [QuickTime]Movie utility.
To specify the file type, checked either TIFF or PICT in the SaveAs dialog
box, which should only appear once.
}
var
  i,stack:integer;
begin
  CheckForStack;
  stack:=PidNumber;
  for i:= 1 to nSlices do begin
    SelectPic(stack);
    SelectSlice(i);
    Duplicate('Frame.',i:3);
    SaveAs;
    {Export;}
    Dispose;
  end;
end;


macro 'Windows to Stack';
{Unlike the menu command of the same name, the windows do not}
{all need to be the same size.}
var
  i,width,height,MinWidth,MinHeight,n,stack:integer;
  isStack:boolean;
begin
  if nPics<=1 then begin
    PutMessage('At least two images must be open.');
    exit;
  end;
  MinWidth:=9999;
  MinHeight:=9999;
  isStack:=false;
  for i:=1 to nPics do begin
    SelectPic(i);
    GetPicSize(width,height);
    if width<MinWidth then MinWidth:=width;
    if height<MinHeight then MinHeight:=height;
    isStack:=isStack or (nSlices>0);
  end;
  if isStack then begin
    PutMessage('This macro does not work with stacks.');
    exit;
  end;
  if odd(MinWidth) then MinWidth:=MinWidth-1;
  n:=nPics;
  SaveState;
  SetNewSize(MinWidth,MinHeight);
  MakeNewStack('Stack');
  stack:=nPics;
  for i:=1 to n do begin
    SelectPic(1);
    MakeRoi(0,0,MinWidth,MinHeight);
    copy;
    Dispose;
    SelectPic(nPics);
    paste;
    if i<>n then AddSlice;
  end;
  KillRoi;
  RestoreState;
end;


Macro 'Stack to Windows'
var
  mystack,i:integer
  width,height:integer;
begin
  SaveState;
  CheckForStack;
  GetPicSize(width,height);
  SetNewSize(width,height);
  mystack := picnumber;
  for i:=1 to nslices do begin
    SelectSlice(i);
    SelectAll;
    copy;
    MakeNewWindow(i);
    paste;
    SelectPic(myStack);
  end;
  KillRoi;
  RestoreState;
end;


macro 'Make Cone';
var
  i,size,margin,MaxRadius,r,r2,center,RodLength,color:integer;
begin
  size:=64;
  margin:=5;
  color:=100;
  SaveState;
  SetBackgroundColor(255); {Black}
  SetNewSize(size,size);
  MakeNewStack('Cone');
  for i:=1 to margin do AddSlice;
  MaxRadius:=(size-2*margin)/2;
  center:=size div 2;
  RodLength:=size-2*margin-1;
  for i:=1 to RodLength do begin
    AddSlice;
    r:=MaxRadius*(i/RodLength);
    MakeOvalRoi(center-r,center-r,r*2,r*2);
    SetForegroundColor(color);
    Fill;
    if (i>RodLength/2) and (i<(RodLength-margin)) then begin
      r2:=MaxRadius/6;
      MakeOvalRoi(center-2.125*r2,center-1.3*r2,r2*2,r2*2);
      SetForegroundColor(color-25);
      Fill;
      MakeOvalRoi(center+0.625*r2,center-0.7*r2,r2*2,r2*2);
      SetForegroundColor(color+25);
      Fill;
    end;
  end;
  for i:=1 to margin do AddSlice;
  KillRoi;
  RestoreState;
end;


procedure DoReslicing(horizontal:boolean);
var
  stack1,stack2,width,height:integer;
  RoiLeft,RoiTop,RoiWidth,RoiHeight,max:integer;
  InputSpacing,OutputSpacing,loc:real;
  FirstTime:boolean;
begin
  RequiresVersion(1.45);
  CheckForStack;
  CheckForSelection;
  SaveState;
  SetBackground(0);
  SetBackground(255);
  stack1:=PicNumber;
  InputSpacing:=GetSliceSpacing;
  if InputSpacing<=0 then InputSpacing:=1;
  InputSpacing:=GetNumber('Input Slice Spacing(Pixels):',InputSpacing);
  SetSliceSpacing(InputSpacing);
  OutputSpacing:=InputSpacing;
  OutputSpacing:=GetNumber('Output Slice Spacing (Pixels):', OutputSpacing);
  FirstTime:=true;
  GetRoi(RoiLeft,RoiTop,RoiWidth,RoiHeight);
  if horizontal then begin
    loc:=RoiTop+OutputSpacing;
    max:=RoiTop+RoiHeight;
  end else begin
    loc:=RoiLeft+OutputSpacing;
    max:=RoiLeft+RoiWidth;
  end;
  while loc<max do begin
    ChoosePic(stack1);
    if horizontal
      then MakeLineRoi(RoiLeft,loc,RoiLeft+RoiWidth,loc)
      else MakeLineRoi(loc,RoiTop,loc,RoiTop+RoiHeight);
    Reslice;
    SelectAll;
    Copy;
    GetPicSize(width,height);
    Dispose;
    if FirstTime then begin
      SetNewSize(width,height);
      MakeNewStack(OutputSpacing:1:2);
      SetSliceSpacing(OutputSpacing);
      stack2:=PicNumber;
    end;
    ChoosePic(stack2);
    if not FirstTime then AddSlice;
    Paste;
    loc:=loc+OutputSpacing;
    FirstTime:=false;
  end;
  SelectPic(stack1);
  KillRoi;
  SelectPic(stack2);
  KillRoi;
  RestoreState;
end;


macro 'Reslice Horizontally…'; begin DoReslicing(true) end;
macro 'Reslice Vertically…';   begin DoReslicing(false) end;